home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / std-class.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-08-27  |  68.7 KB  |  1,737 lines

  1. ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (defmethod slot-accessor-function ((slotd effective-slot-definition) type)
  31.   (ecase type
  32.     (reader (slot-definition-reader-function slotd))
  33.     (writer (slot-definition-writer-function slotd))
  34.     (boundp (slot-definition-boundp-function slotd))))
  35.  
  36. (defvar *dfuns-needing-update* NIL)
  37. (defvar *classes-being-updated* NIL)
  38.  
  39. (defmethod update-slot-accessor-function ((slotd effective-slot-definition)
  40.                                           type function
  41.                                           &optional (update-accessors-p T))
  42.   (ecase type
  43.     (reader (setf (slot-definition-reader-function slotd) function)
  44.             (when (and update-accessors-p (eq *boot-state* 'complete))
  45.               (dolist (reader (slot-definition-readers slotd))
  46.                 (pushnew reader *dfuns-needing-update* :test #'eq))))
  47.     (writer (setf (slot-definition-writer-function slotd) function)
  48.             (when (and update-accessors-p (eq *boot-state* 'complete))
  49.               (dolist (writer (slot-definition-writers slotd))
  50.                 (pushnew writer *dfuns-needing-update*))))
  51.     (boundp (setf (slot-definition-boundp-function slotd) function))))
  52.  
  53. (defconstant *slotd-reader-function-std-p* 1)
  54. (defconstant *slotd-writer-function-std-p* 2)
  55. (defconstant *slotd-boundp-function-std-p* 4)
  56. (defconstant *slotd-all-function-std-p*    7)
  57.  
  58. (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
  59.   (let ((flags (slot-value slotd 'accessor-flags)))
  60.     (declare (type index flags))
  61.     (if (eq type 'all)
  62.     (= *slotd-all-function-std-p* flags)
  63.     (let ((mask (ecase type
  64.               (reader *slotd-reader-function-std-p*)
  65.               (writer *slotd-writer-function-std-p*)
  66.               (boundp *slotd-boundp-function-std-p*))))
  67.       (declare (type index mask))
  68.       (not (zerop (the index (logand mask flags))))))))
  69.  
  70. (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type)
  71.   (let ((mask (ecase type
  72.         (reader *slotd-reader-function-std-p*)
  73.         (writer *slotd-writer-function-std-p*)
  74.         (boundp *slotd-boundp-function-std-p*)))
  75.     (flags (slot-value slotd 'accessor-flags)))
  76.     (declare (type index mask flags))
  77.     (setf (slot-value slotd 'accessor-flags)
  78.       (if value
  79.           (the index (logior mask flags))
  80.           (the index (logand (the index (lognot mask)) flags)))))
  81.   value)
  82.  
  83. (defvar *name->class->slotd-table* (make-hash-table))
  84.  
  85. (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition))
  86.   (let* ((name (slot-value slotd 'name))
  87.      (class (slot-value slotd 'class))
  88.      (old-slotd (and (slot-boundp class 'slots)
  89.                          (find-slot-definition class name))))
  90.     (let ((table (or (gethash name *name->class->slotd-table*)
  91.              (setf (gethash name *name->class->slotd-table*)
  92.                (make-hash-table :test 'eq :size 5)))))
  93.       (setf (gethash class table) slotd))
  94.     (dolist (type '(reader writer boundp))
  95.       (multiple-value-bind (function std-p)
  96.       (if (eq *boot-state* 'complete)
  97.           (let* ((gf-name (ecase type
  98.                 (reader 'slot-value-using-class)
  99.                 (writer '(setf slot-value-using-class))
  100.                 (boundp 'slot-boundp-using-class)))
  101.              (gf (gdefinition gf-name)))
  102.         (get-accessor-method-function gf type class slotd))
  103.           (get-optimized-std-accessor-method-function class slotd type))
  104.     (setf (slot-accessor-std-p slotd type) std-p)
  105.         (let ((old-function
  106.                 (if old-slotd (slot-accessor-function old-slotd type))))
  107.       (update-slot-accessor-function slotd type function
  108.             (and old-function (neq function old-function))))))))
  109.  
  110. (defmethod initialize-internal-slot-functions :after
  111.           ((slotd standard-effective-slot-definition))
  112.   (let ((name (slot-definition-name slotd)))
  113.     (unless *safe-to-use-slot-value-wrapper-optimizations-p*
  114.       (initialize-internal-slot-reader-gfs name))
  115.     (unless *safe-to-use-set-slot-value-wrapper-optimizations-p*
  116.       (initialize-internal-slot-writer-gfs name))
  117.     (unless *safe-to-use-slot-boundp-wrapper-optimizations-p*
  118.       (initialize-internal-slot-boundp-gfs name))))
  119.  
  120. (defmethod (setf slot-definition-reader-function) :after 
  121.     (new-value (slotd effective-slot-definition))
  122.   (setf (internal-slotd-reader-function (slot-value slotd 'internal-slotd))
  123.         new-value))
  124.  
  125. (defmethod (setf slot-definition-writer-function) :after 
  126.     (new-value (slotd effective-slot-definition))
  127.   (setf (internal-slotd-writer-function (slot-value slotd 'internal-slotd))
  128.         new-value))
  129.  
  130. (defmethod (setf slot-definition-boundp-function) :after 
  131.     (new-value (slotd effective-slot-definition))
  132.   (setf (internal-slotd-boundp-function (slot-value slotd 'internal-slotd))
  133.         new-value))
  134.  
  135. (defmethod (setf slot-definition-location) :after 
  136.     (location (slotd standard-effective-slot-definition))
  137.   (setf (internal-slotd-location (slot-value slotd 'internal-slotd))
  138.         location)
  139.   (initialize-internal-slot-functions slotd))
  140.  
  141.  
  142.  
  143. (defmethod documentation (object &optional doc-type)
  144.   (lisp:documentation object doc-type))
  145.  
  146. (defmethod (setf documentation) (new-value object &optional doc-type)
  147.   (declare (ignore new-value doc-type))
  148.   (error "Can't change the documentation of ~S." object))
  149.  
  150.  
  151. (defmethod documentation ((object documentation-mixin)
  152.                           &optional (doc-type NIL doc-type-p))
  153.   (if doc-type-p
  154.       (error
  155.         "Doc-type parameter (~S) supplied to documentation called
  156.          on PCL object ~S"
  157.         doc-type object)
  158.      (slot-value object 'documentation)))
  159.  
  160. (defmethod (setf documentation) (new-value (object documentation-mixin)
  161.                                  &optional (doc-type NIL doc-type-p))
  162.   (if doc-type-p
  163.       (error
  164.         "Doc-type parameter (~S) supplied to (setf documentation) called
  165.          on PCL object ~S"
  166.         doc-type object)
  167.       (setf (slot-value object 'documentation) new-value)))
  168.  
  169. (defmethod shared-initialize :before ((object documentation-mixin)
  170.                                       slot-names
  171.                                       &key documentation)
  172.   (declare (ignore slot-names))
  173.   (unless (legal-documentation-p object documentation)
  174.     (error "When initializing the ~A ~S:~%~
  175.             The ~S initialization argument was: ~A.~%~
  176.             It must be a string or nil."
  177.        (string-downcase (symbol-name (class-name (class-of object))))
  178.        object :documentation documentation)))
  179.  
  180. (defmethod legal-documentation-p ((object documentation-mixin) x)
  181.   (or (null x) (stringp x)))
  182.  
  183.  
  184.  
  185.  
  186. ;;;
  187. ;;; Various class accessors that are a little more complicated than can be
  188. ;;; done with automatically generated reader methods.
  189. ;;;
  190.  
  191. (defmethod class-prototype ((class std-class))
  192.   (with-slots (prototype) class
  193.     (or prototype
  194.         (if (memq class *classes-being-updated*)
  195.             (allocate-instance class)
  196.             (setq prototype (make-class-prototype class))))))
  197.  
  198. (defmethod make-class-prototype ((class std-class))
  199.   (let ((proto (allocate-instance class))
  200.         (normal-slots nil))
  201.     (dolist (slotd (class-slots class))
  202.       (when (or (typep (slot-definition-location slotd) 'fixnum)
  203.                 (consp (slot-definition-location slotd)))
  204.         (push slotd normal-slots)))
  205.     (shared-initialize proto normal-slots :check-initargs-legality-p NIL)
  206.     proto))
  207.  
  208. (defmethod class-constructors ((class slot-class))
  209.   (plist-value class 'constructors))
  210.  
  211. (defmethod class-slot-cells ((class std-class))
  212.   (plist-value class 'class-slot-cells))
  213.  
  214. (defmethod (setf class-name) (new-value (class std-class))
  215.   (reinitialize-instance class :name new-value))
  216.  
  217. (defmethod slot-unbound :around ((class class) class-instance slot-name)
  218.   (let ((documented-reader
  219.           (case slot-name
  220.             (default-initargs      'class-default-initargs)
  221.             (class-precedence-list 'class-precedence-list)
  222.             (prototype             'class-prototype)
  223.             (slots                 'class-slots))))
  224.     (if documented-reader
  225.         (if (class-finalized-p class-instance)
  226.             (error "Huh? -- ~S slot unbound in ~S when finalized."
  227.                    slot-name class-instance)
  228.             (error "~S called on ~S before it is finalized."
  229.                    documented-reader class-instance))
  230.         (call-next-method))))
  231.  
  232.  
  233. ;;;
  234. ;;; Class accessors that are even a little bit more complicated than those
  235. ;;; above.  These have a protocol for updating them, we must implement that
  236. ;;; protocol.
  237. ;;; 
  238.  
  239. ;;;
  240. ;;; Maintaining the direct subclasses backpointers.  The update methods are
  241. ;;; here, the values are read by an automatically generated reader method.
  242. ;;; 
  243. (defmethod add-direct-subclass ((class class) (subclass class))
  244.   (with-slots (direct-subclasses) class
  245.     (pushnew subclass direct-subclasses)
  246.     subclass))
  247.  
  248. (defmethod remove-direct-subclass ((class class) (subclass class))
  249.   (with-slots (direct-subclasses) class
  250.     (setq direct-subclasses (remove subclass direct-subclasses))
  251.     subclass))
  252.  
  253. ;;;
  254. ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
  255. ;;;
  256. ;;; There are four generic functions involved, each has one method for the
  257. ;;; class case and another method for the damned EQL specializers. All of
  258. ;;; these are specified methods and appear in their specified place in the
  259. ;;; class graph.
  260. ;;;
  261. ;;;   ADD-DIRECT-METHOD
  262. ;;;   REMOVE-DIRECT-METHOD
  263. ;;;   SPECIALIZER-DIRECT-METHODS
  264. ;;;   SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
  265. ;;;
  266. ;;; In each case, we maintain one value which is a cons.  The car is the list
  267. ;;; methods.  The cdr is a list of the generic functions.  The cdr is always
  268. ;;; computed lazily.
  269. ;;;
  270.  
  271. (defmethod add-direct-method ((specializer class) (method method))
  272.   (with-slots (direct-methods) specializer
  273.     (setf (car direct-methods) (adjoin method (car direct-methods))    ;PUSH
  274.       (cdr direct-methods) ()))
  275.   method)
  276.  
  277. (defmethod remove-direct-method ((specializer class) (method method))
  278.   (with-slots (direct-methods) specializer
  279.     (setf (car direct-methods) (remove method (car direct-methods))
  280.       (cdr direct-methods) ()))
  281.   method)
  282.  
  283. (defmethod specializer-direct-methods ((specializer class))
  284.   (with-slots (direct-methods) specializer
  285.     (car direct-methods)))
  286.  
  287. (defmethod specializer-direct-generic-functions ((specializer class))
  288.   (with-slots (direct-methods) specializer
  289.     (or (cdr direct-methods)
  290.     (setf (cdr direct-methods)
  291.           (gathering1 (collecting-once)
  292.         (dolist (m (car direct-methods))
  293.           (gather1 (method-generic-function m))))))))
  294.  
  295.  
  296.  
  297. ;;;
  298. ;;; This hash table is used to store the direct methods and direct generic
  299. ;;; functions of EQL specializers.  Each value in the table is the cons.
  300. ;;; 
  301. (defvar *eql-specializer-methods* (make-hash-table :test #'eql))
  302. (defvar *class-eq-specializer-methods* (make-hash-table :test #'eq))
  303.  
  304. (defmethod specializer-method-table ((specializer eql-specializer))
  305.   *eql-specializer-methods*)
  306.  
  307. (defmethod specializer-method-table ((specializer class-eq-specializer))
  308.   *class-eq-specializer-methods*)
  309.  
  310. (defmethod add-direct-method ((specializer specializer-with-object) (method method))
  311.   (let* ((object (specializer-object specializer))
  312.      (table (specializer-method-table specializer))
  313.      (entry (gethash object table)))
  314.     (unless entry
  315.       (setq entry
  316.         (setf (gethash object table)
  317.           (cons nil nil))))
  318.     (setf (car entry) (adjoin method (car entry))
  319.       (cdr entry) ())
  320.     method))
  321.  
  322. (defmethod remove-direct-method ((specializer specializer-with-object) (method method))
  323.   (let* ((object (specializer-object specializer))
  324.      (entry (gethash object (specializer-method-table specializer))))
  325.     (when entry
  326.       (setf (car entry) (remove method (car entry))
  327.         (cdr entry) ()))
  328.     method))
  329.  
  330. (defmethod specializer-direct-methods ((specializer specializer-with-object))  
  331.   (car (gethash (specializer-object specializer)
  332.         (specializer-method-table specializer))))
  333.  
  334. (defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
  335.   (let* ((object (specializer-object specializer))
  336.      (entry (gethash object (specializer-method-table specializer))))
  337.     (when entry
  338.       (or (cdr entry)
  339.       (setf (cdr entry)
  340.         (gathering1 (collecting-once)
  341.           (dolist (m (car entry))
  342.             (gather1 (method-generic-function m)))))))))
  343.  
  344. (defun map-all-classes (function &optional (root-name 't))
  345.   (declare (type real-function function))
  346.   (labels ((do-class (class)
  347.          (mapc #'do-class (class-direct-subclasses class))
  348.          (funcall function class)))
  349.     (do-class (find-class root-name))))
  350.  
  351. (defun map-specializers (function)
  352.   (declare (type real-function function))
  353.   (map-all-classes #'(lambda (class)
  354.                (funcall function (class-eq-specializer class))
  355.                (funcall function class)))
  356.   (maphash #'(lambda (object methods)
  357.            (declare (ignore methods))
  358.            (intern-eql-specializer object))
  359.        *eql-specializer-methods*)
  360.   (maphash #'(lambda (object specl)
  361.            (declare (ignore object))
  362.            (funcall function specl))
  363.        *eql-specializer-table*)
  364.   nil)
  365.  
  366. (defun map-all-generic-functions (function)
  367.   (declare (type real-function function))
  368.   (let ((all-generic-functions (make-hash-table :test 'eq)))
  369.     (map-specializers #'(lambda (specl)
  370.               (dolist (gf (specializer-direct-generic-functions specl))
  371.                 (unless (gethash gf all-generic-functions)
  372.                   (setf (gethash gf all-generic-functions) t)
  373.                   (funcall function gf))))))
  374.   nil)
  375.  
  376. (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
  377.   (declare (ignore slot-names))
  378.   (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
  379.  
  380. (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
  381.   (declare (ignore slot-names))
  382.   (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
  383.  
  384.  
  385.  
  386. (defun real-load-defclass (name metaclass-name supers slots other accessors)
  387.   (do-standard-defsetfs-for-defclass accessors)                    ;***
  388.   (apply #'ensure-class name :metaclass metaclass-name
  389.                  :direct-superclasses supers
  390.                  :direct-slots slots
  391.                  :definition-source `((defclass ,name)
  392.                           ,(load-truename))
  393.                  other))
  394.  
  395. (declaim (ftype (function (T T) (values T list)) ensure-class-values))
  396. (defun ensure-class-values (class args)
  397.   (let* ((initargs (copy-list args))
  398.      (unsupplied (list 1))
  399.      (supplied-meta   (getf initargs :metaclass unsupplied))
  400.      (supplied-supers (getf initargs :direct-superclasses unsupplied))
  401.      (supplied-slots  (getf initargs :direct-slots unsupplied))
  402.      (meta
  403.        (cond ((neq supplied-meta unsupplied)
  404.           (find-class supplied-meta))
  405.          ((or (null class)
  406.               (forward-referenced-class-p class))
  407.           *the-class-standard-class*)
  408.          (t
  409.           (class-of class)))))  
  410.     (flet ((fix-super (s)
  411.          (cond ((classp s) s)
  412.            ((not (legal-class-name-p s))
  413.             (error "~S is not a class or a legal class name." s))
  414.            (t
  415.             (or (find-class s nil)
  416.             (setf (find-class s)
  417.                   (make-instance 'forward-referenced-class
  418.                          :name s)))))))      
  419.       (loop (unless (remf initargs :metaclass) (return)))
  420.       (loop (unless (remf initargs :direct-superclasses) (return)))
  421.       (loop (unless (remf initargs :direct-slots) (return)))
  422.       (values meta
  423.           (list* :direct-superclasses
  424.              (and (neq supplied-supers unsupplied)
  425.               (mapcar #'fix-super supplied-supers))
  426.              :direct-slots
  427.              (and (neq supplied-slots unsupplied) supplied-slots)
  428.              initargs)))))
  429.  
  430. (defun ensure-class (name &rest all)
  431.   (apply #'ensure-class-using-class name (find-class name nil) all))
  432.  
  433. (defmethod ensure-class-using-class (name (class null) &rest args &key)
  434.   (multiple-value-bind (meta initargs)
  435.       (ensure-class-values class args)
  436.     (setf class (apply #'make-instance meta :name name initargs))
  437.     class))
  438.  
  439. (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
  440.   (declare (ignore name))
  441.   (multiple-value-bind (meta initargs)
  442.       (ensure-class-values class args)
  443.     (unless (eq (class-of class) meta) (change-class class meta))
  444.     (apply #'reinitialize-instance class initargs)
  445.     class))
  446.  
  447.  
  448. ;;;
  449. ;;;
  450. ;;;
  451.  
  452. (defmethod shared-initialize :before ((class std-class)
  453.                       slot-names
  454.                       &key (name nil name-p))
  455.   (declare (ignore slot-names))
  456.   (when name-p
  457.     (unless (legal-class-name-p name)
  458.       (error "~S is not a legal class name." name))
  459.     (when (slot-boundp class 'name)
  460.       (setf (find-class (slot-value class 'name)) nil))))
  461.  
  462. (defmethod make-direct-slotd ((class std-class) &rest initargs)
  463.   (let ((initargs (list* :class class initargs)))
  464.     (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
  465.  
  466. (defmethod shared-initialize :after
  467.        ((class std-class)
  468.         slot-names
  469.         &key (direct-superclasses nil direct-superclasses-p)
  470.          (direct-slots nil direct-slots-p)
  471.          (direct-default-initargs nil direct-default-initargs-p)
  472.              (predicate-name nil predicate-name-p))
  473.   (declare (ignore slot-names))
  474.   (if direct-superclasses-p
  475.       (progn
  476.         (setq direct-superclasses (or direct-superclasses
  477.                                       (list *the-class-standard-object*)))
  478.         (dolist (superclass direct-superclasses)
  479.       (unless (validate-superclass class superclass)
  480.         (error "The class ~S was specified as a~%super-class of the class ~S;~%~
  481.                     but the meta-classes ~S and~%~S are incompatible."
  482.            superclass class (class-of superclass) (class-of class))))
  483.         (setf (slot-value class 'direct-superclasses) direct-superclasses))
  484.       (setq direct-superclasses (slot-value class 'direct-superclasses)))
  485.   (setq direct-slots
  486.     (if direct-slots-p
  487.         (setf (slot-value class 'direct-slots)
  488.           (mapcar #'(lambda (pl) (apply #'make-direct-slotd class pl))
  489.                           direct-slots))
  490.         (slot-value class 'direct-slots)))
  491.   (if direct-default-initargs-p
  492.       (setf (slot-value class 'direct-default-initargs) direct-default-initargs)
  493.       (setq direct-default-initargs (class-direct-default-initargs class)))
  494.   (setf (plist-value class 'class-slot-cells)
  495.     (gathering1 (collecting)
  496.       (dolist (dslotd direct-slots)
  497.         (when (eq (slot-definition-allocation dslotd) class)
  498.           (let ((initfunction (slot-definition-initfunction dslotd)))
  499.         (gather1 (cons (slot-definition-name dslotd)
  500.                    (if initfunction 
  501.                    (slot-initfunction-funcall initfunction)
  502.                    *slot-unbound*))))))))
  503.   (let ((name (class-name class)))
  504.     (when name
  505.       (if predicate-name-p
  506.           (progn
  507.             (setf (slot-value class 'predicate-name) (car predicate-name))
  508.             (setf (find-class-predicate name) (make-class-predicate class)))
  509.           (unless (slot-value class 'predicate-name)
  510.         (setf (slot-value class 'predicate-name)
  511.               (make-class-predicate-name name))))
  512.       (setf (find-class name) class)
  513.       (inform-type-system-about-class class name)))
  514.   (add-direct-subclasses class direct-superclasses)
  515.   (add-slot-accessors    class direct-slots))
  516.  
  517. (defmethod shared-initialize :before ((class class) slot-names &key)
  518.   (declare (ignore slot-names))
  519.   (setf (slot-value class 'type) `(class ,class))
  520.   (setf (slot-value class 'class-eq-specializer)
  521.     (make-instance 'class-eq-specializer :class class)))
  522.  
  523. (defmethod reinitialize-instance :before ((class slot-class) &key)
  524.   (remove-direct-subclasses class (class-direct-superclasses class))
  525.   (remove-slot-accessors    class (class-direct-slots class)))
  526.  
  527. (defmethod reinitialize-instance :after ((class std-class)
  528.                      &rest initargs
  529.                      &key)
  530.   (update-class class nil)
  531.   (map-dependents class
  532.           #'(lambda (dependent)
  533.               (apply #'update-dependent class dependent initargs))))
  534.  
  535.  
  536.  
  537. (defun make-class-predicate (class)
  538.   (let* ((name (class-predicate-name class))
  539.          (gf (ensure-generic-function name))
  540.          (method-class (find-class 'standard-method nil))
  541.          (method-proto
  542.            (if (and method-class (class-finalized-p method-class))
  543.                (class-prototype method-class)))
  544.          (store-method-function-p
  545.           (call-store-method-function-p gf method-proto nil))
  546.          (store-method-optimized-function-p
  547.           (call-store-method-optimized-function-p gf method-proto nil))
  548.      (mlist (if (eq *boot-state* 'complete)
  549.             (generic-function-methods gf)
  550.             (early-gf-methods gf))))
  551.     (unless mlist
  552.       (unless (eq class *the-class-t*)
  553.     (let ((default-method
  554.                 (make-a-method
  555.                   'standard-method
  556.               ()
  557.               (list 'object)
  558.               (list *the-class-t*)
  559.                   (when store-method-function-p
  560.                     #'documented-function-returning-nil)
  561.                   (when store-method-optimized-function-p
  562.                     #'function-returning-nil)
  563.               NIL
  564.               "class predicate default method"
  565.                   NIL
  566.                   `(:constant-value NIL))))
  567.       (add-method gf default-method)))
  568.       (let ((class-method
  569.               (make-a-method
  570.                 'standard-method
  571.             ()
  572.             (list 'object)
  573.         (list class)
  574.                 (when store-method-function-p
  575.                   #'documented-function-returning-t)
  576.                 (when store-method-optimized-function-p
  577.                   #'function-returning-t)
  578.             NIL
  579.         "class predicate class method"
  580.                 NIL
  581.                 `(:constant-value T))))
  582.     (add-method gf class-method)))
  583.     gf))
  584.  
  585. (defun fix-dfuns-needing-update ()
  586.   (loop (unless *dfuns-needing-update* (return T))
  587.         (let ((name (pop *dfuns-needing-update*)))
  588.           (when (gboundp name)
  589.             (update-dfun (gdefinition name))))))
  590.  
  591. (defun add-slot-accessors (class dslotds)
  592.   (fix-slot-accessors class dslotds 'add))
  593.  
  594. (defun remove-slot-accessors (class dslotds)
  595.   (fix-slot-accessors class dslotds 'remove))
  596.  
  597. (defun fix-slot-accessors (class dslotds add/remove)  
  598.   (flet ((fix (gfspec name dslot r/w)
  599.        (let ((gf (ensure-generic-function gfspec)))
  600.          (case r/w
  601.            (r (if (eq add/remove 'add)
  602.               (add-reader-method class gf name dslot)
  603.               (remove-reader-method class gf)))
  604.            (w (if (eq add/remove 'add)
  605.               (add-writer-method class gf name dslot)
  606.               (remove-writer-method class gf)))))))
  607.     (dolist (dslotd dslotds)
  608.       (let ((name (slot-definition-name dslotd)))
  609.         (dolist (r (slot-definition-readers dslotd)) (fix r name dslotd 'r))
  610.         (dolist (w (slot-definition-writers dslotd)) (fix w name dslotd 'w)))))
  611.   (fix-dfuns-needing-update))
  612.  
  613.  
  614. (defun add-direct-subclasses (class new)
  615.   (dolist (n new)
  616.     (unless (memq class (class-direct-subclasses class))
  617.       (add-direct-subclass n class))))
  618.  
  619. (defun remove-direct-subclasses (class new)
  620.   (let ((old (class-direct-superclasses class)))
  621.     (dolist (o (set-difference old new))
  622.       (remove-direct-subclass o class))))
  623.  
  624.  
  625. ;;;
  626. ;;;
  627. ;;;
  628.  
  629. (defvar *notify-finalize* NIL)
  630.  
  631. (defmethod finalize-inheritance ((class std-class))
  632.   (when *notify-finalize*
  633.     (warn "Finalizing ~S" class))
  634.   (update-class class t))
  635.  
  636. (defmacro assure-finalized (class)
  637.   (once-only (class)
  638.     `(unless (class-finalized-p ,class) (finalize-inheritance ,class))))
  639.  
  640.  
  641.  
  642.       
  643. ;;;
  644. ;;; Called by :after shared-initialize whenever a class is initialized or 
  645. ;;; reinitialized.  The class may or may not be finalized.
  646. ;;; 
  647. (defun update-class (class finalizep)  
  648.   (when (or finalizep (class-finalized-p class))
  649.     (push class *classes-being-updated*)
  650.     (update-cpl class (compute-class-precedence-list class))
  651.     (update-slots class)
  652.     (update-gfs-of-class class)
  653.     (update-inits class (compute-default-initargs class))
  654.     (update-constructors class)
  655.     (setf *classes-being-updated* (delete class *classes-being-updated*)))
  656.   (unless finalizep
  657.     (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
  658.  
  659. (defun update-cpl (class cpl)
  660.   (when (class-finalized-p class)
  661.     (unless (equal (class-precedence-list class) cpl)
  662.       (force-cache-flushes class)))
  663.   (fast-set-slot-value class 'class-precedence-list cpl slow-slot-value)
  664.   (let ((wrapper (class-wrapper class)))
  665.     (when wrapper
  666.       (setf (wrapper-class-precedence-list wrapper) cpl)))
  667.   (update-class-can-precede-p cpl))
  668.  
  669. (defun update-class-can-precede-p (cpl)
  670.   (when cpl
  671.     (let* ((first (car cpl))
  672.            (orig-precede-list
  673.              (fast-slot-value first 'can-precede-list slow-slot-value))
  674.            (precede-list orig-precede-list))
  675.       (dolist (c (cdr cpl))
  676.         (unless (memq c precede-list)
  677.           (setf precede-list (cons c precede-list))))
  678.       (unless (eq precede-list orig-precede-list)
  679.         (fast-set-slot-value first 'can-precede-list precede-list
  680.                              slow-slot-value)))
  681.     (update-class-can-precede-p (cdr cpl))))
  682.  
  683. (defun class-can-precede-p (class1 class2)
  684.   (memq class2 (class-can-precede-list class1)))
  685.  
  686.  
  687. (declaim (ftype (function (T T) (values list list)) compute-storage-info))
  688. (defmethod compute-storage-info ((class std-class) eslotds)
  689.   (let ((instance-slots ())
  690.     (class-slots    ()))
  691.     (dolist (eslotd eslotds)
  692.       (let ((alloc (slot-definition-allocation eslotd)))
  693.     (cond ((eq alloc :instance) (push eslotd instance-slots))
  694.           ((classp alloc)       (push eslotd class-slots)))))
  695.     (values (compute-instance-layout class instance-slots)
  696.         (compute-class-slots class class-slots))))
  697.  
  698. (defmethod compute-instance-layout ((class std-class) instance-eslotds)
  699.   (mapcar #'slot-definition-name
  700.           (sort instance-eslotds #'< :key #'slot-definition-location)))
  701.  
  702. (defmethod compute-class-slots ((class std-class) eslotds)
  703.   (gathering1 (collecting)
  704.     (dolist (eslotd eslotds)
  705.       (gather1
  706.     (assq (slot-definition-name eslotd)
  707.           (class-slot-cells (slot-definition-allocation eslotd)))))))
  708.  
  709. (defmethod compute-layout ((class std-class) cpl instance-eslotds)
  710.   (let* ((names
  711.        (gathering1 (collecting)
  712.          (dolist (eslotd instance-eslotds)
  713.            (gather1 (slot-definition-name eslotd)))))
  714.      (order ()))
  715.     (labels ((rwalk (tail)
  716.            (when tail
  717.          (rwalk (cdr tail))
  718.          (dolist (ss (class-direct-slots (car tail)))
  719.            (let ((n (slot-definition-name ss)))
  720.              (when (memq n names)
  721.                (setq order (cons n order)
  722.                  names (remove n names))))))))
  723.       (rwalk cpl)
  724.       (nreverse order))))
  725.  
  726. (defun update-slots (class)
  727.   (let* ((owrapper
  728.            (class-wrapper class))
  729.          (nwrapper
  730.            (or owrapper
  731.                (progn
  732.                  ;; The class isn't really totally finalized, but the
  733.                  ;; class finalization functions have to think it is.
  734.                  (fast-set-slot-value class 'finalized-p T slow-slot-value)
  735.                  (setf (fast-slot-value class 'prototype) nil)
  736.                  (setf (fast-slot-value class 'wrapper) (make-wrapper class)))))
  737.          (eslotds
  738.            (compute-slots class)))
  739.     (multiple-value-bind (nlayout nwrapper-class-slots)
  740.         (compute-storage-info class eslotds)
  741.       (declare (type list nlayout nwrapper-class-slots))
  742.       ;;
  743.       ;; If there is a change in the shape of the instances then the
  744.       ;; old class is now obsolete.
  745.       ;;
  746.       (let* ((olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
  747.          (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
  748.              (make-instances-obsolete-p
  749.                (not (or (null owrapper)
  750.                 (and (equal nlayout olayout)
  751.                  (not
  752.                   (iterate ((o (list-elements owrapper-class-slots))
  753.                         (n (list-elements nwrapper-class-slots)))
  754.                        (unless (eq (car o) (car n)) (return t)))))))))
  755.         (declare (type list    olayout owrapper-class-slots)
  756.                  (type boolean make-instances-obsolete-p))
  757.         (when (or (null owrapper) make-instances-obsolete-p)
  758.           (let ((internal-slotds ())
  759.                 (side-effect-internal-slotds ()))
  760.             (dolist (eslotd eslotds)
  761.               (let ((internal-slotd (slot-definition-internal-slotd eslotd)))
  762.                 (push internal-slotd internal-slotds)
  763.                 (unless (slot-definition-initfunction-side-effect-free-p eslotd)
  764.                   (push internal-slotd side-effect-internal-slotds))))
  765.             (setf (slow-slot-value class 'slots) eslotds
  766.                   (slow-slot-value class 'internal-slotds)
  767.                     (nreverse internal-slotds)
  768.                   (slow-slot-value class 'side-effect-internal-slotds)
  769.                     (nreverse side-effect-internal-slotds)))
  770.           (setf ;; nwrapper is already the same as the class-wrapper
  771.             (wrapper-instance-slots-layout nwrapper) nlayout
  772.                 (wrapper-allocate-static-slot-storage-copy nwrapper)
  773.                   (%allocate-origional-static-slot-storage-copy (length nlayout))
  774.             (wrapper-class-slots           nwrapper) nwrapper-class-slots)
  775.           (unless owrapper
  776.             (setf (wrapper-class-precedence-list nwrapper)
  777.                   (fast-slot-value class 'class-precedence-list))
  778.             (setf (wrapper-unreserved-field    nwrapper) NIL)))
  779.         (when make-instances-obsolete-p
  780.           (make-instances-obsolete class))
  781.         (initialize-allocate-static-slot-storage-copy class)))))
  782.  
  783. (defmethod initialize-allocate-static-slot-storage-copy ((class std-class))
  784.   (let* ((dummy-instance (allocate-instance class))
  785.          (side-effect-free-slots
  786.            (let ((collect nil))
  787.              (dolist (slot (class-slots class) collect)
  788.                (when (slot-definition-initfunction-side-effect-free-p slot)
  789.                  (let ((location (slot-definition-location slot)))
  790.                    (when (or (typep location 'fixnum) (consp location))
  791.                      (push (slot-definition-name slot) collect)))))))
  792.          (wrapper (class-wrapper class))
  793.          (old-allocate-static-slot-storage-copy
  794.           (wrapper-allocate-static-slot-storage-copy wrapper)))
  795.     (shared-initialize dummy-instance side-effect-free-slots
  796.                        :check-initargs-legality-p NIL)
  797.     (setf (wrapper-allocate-static-slot-storage-copy wrapper)
  798.           (or (get-slots-or-nil dummy-instance)
  799.               old-allocate-static-slot-storage-copy))))
  800.  
  801. (defun update-gfs-of-class (class)
  802.   (when (let ((cpl (class-precedence-list class)))
  803.       (or (memq *the-class-slot-class* cpl)
  804.           (memq *the-class-standard-effective-slot-definition* cpl)))
  805.     (let ((gf-table (make-hash-table :test 'eq)))
  806.       (labels ((collect-gfs (class)
  807.          (dolist (gf (specializer-direct-generic-functions class))
  808.            (setf (gethash gf gf-table) t))
  809.          (mapc #'collect-gfs (class-direct-superclasses class))))
  810.     (collect-gfs class)
  811.     (maphash #'(lambda (gf ignore)
  812.              (declare (ignore ignore))
  813.              (update-gf-dfun class gf))
  814.          gf-table)))))
  815.  
  816. (defun update-inits (class inits)
  817.   (setf (slot-value class 'default-initargs) inits))
  818.  
  819.  
  820. ;;;
  821. ;;;
  822. ;;;
  823. (defmethod compute-default-initargs ((class slot-class))
  824.   (let ((cpl (class-precedence-list class))
  825.     (direct (class-direct-default-initargs class)))
  826.     (labels ((walk (tail)
  827.            (if (null tail)
  828.            nil
  829.            (let ((c (pop tail)))
  830.              (append (if (eq c class)
  831.                  direct 
  832.                  (class-direct-default-initargs c))
  833.                  (walk tail))))))
  834.       (let ((initargs (walk cpl)))
  835.     (delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
  836.  
  837.  
  838. ;;;
  839. ;;; Protocols for constructing direct and effective slot definitions.
  840. ;;;
  841. ;;; 
  842. ;;;
  843. ;;;
  844. (defmethod direct-slot-definition-class ((class std-class) initargs)
  845.   (declare (ignore initargs))
  846.   (find-class 'standard-direct-slot-definition))
  847.  
  848. ;;;
  849. ;;;
  850. ;;;
  851. (defmethod compute-slots ((class std-class))
  852.   ;;
  853.   ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
  854.   ;; for each different slot name we find in our superclasses.  Each
  855.   ;; call receives the class and a list of the dslotds with that name.
  856.   ;; The list is in most-specific-first order.
  857.   ;;
  858.   (let ((name-dslotds-alist ()))
  859.     (dolist (c (slot-value class 'class-precedence-list))
  860.       (let ((dslotds (class-direct-slots c)))
  861.     (dolist (d dslotds)
  862.       (let* ((name (slot-definition-name d))
  863.          (entry (assq name name-dslotds-alist)))
  864.         (if entry
  865.         (push d (cdr entry))
  866.         (push (list name d) name-dslotds-alist))))))
  867.     (mapcar #'(lambda (direct)
  868.         (compute-effective-slot-definition class
  869.                                                    (car direct)
  870.                            (nreverse (cdr direct))))
  871.         name-dslotds-alist)))
  872.  
  873. (defmethod compute-slots :around ((class std-class))
  874.   (let ((eslotds (call-next-method))
  875.     (cpl (slot-value class 'class-precedence-list))
  876.     (instance-slots ())
  877.     (class-slots    ())
  878.         (other-slots    ()))
  879.     (dolist (eslotd eslotds)
  880.       (let ((alloc (slot-definition-allocation eslotd)))
  881.     (cond ((eq alloc :instance) (push eslotd instance-slots))
  882.           ((classp alloc)       (push eslotd class-slots))
  883.               (T                    (push eslotd other-slots)))))
  884.     (let ((nlayout (compute-layout class cpl instance-slots)))
  885.       (declare (type list nlayout))
  886.       (dolist (eslotd instance-slots)
  887.     (setf (slot-definition-location eslotd) 
  888.           (posq (slot-definition-name eslotd) nlayout))))
  889.     (dolist (eslotd class-slots)
  890.       (setf (slot-definition-location eslotd) 
  891.         (assq (slot-definition-name eslotd)
  892.           (class-slot-cells (slot-definition-allocation eslotd)))))
  893.     (dolist (eslotd other-slots)
  894.       (initialize-internal-slot-functions eslotd))
  895.     eslotds))
  896.  
  897. (defmethod compute-effective-slot-definition ((class standard-class) name dslotds)
  898.   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
  899.      (class (effective-slot-definition-class class initargs))
  900.          (slot-definition (apply #'make-instance class initargs))
  901.          (internal-slotd
  902.            (make-internal-slotd
  903.              :name name
  904.              :slot-definition slot-definition
  905.              :location        (slot-definition-location     slot-definition)
  906.              :initargs        (slot-definition-initargs     slot-definition)
  907.              :initfunction    (slot-definition-initfunction slot-definition))))
  908.     (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
  909.     slot-definition))
  910.  
  911. (defmethod compute-effective-slot-definition ((class funcallable-standard-class)
  912.                                               name dslotds)
  913.   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
  914.      (class (effective-slot-definition-class class initargs))
  915.          (slot-definition (apply #'make-instance class initargs))
  916.          (internal-slotd
  917.            (make-internal-slotd
  918.              :name name
  919.              :slot-definition slot-definition
  920.              :location        (slot-definition-location     slot-definition)
  921.              :initargs        (slot-definition-initargs     slot-definition)
  922.              :initfunction    (slot-definition-initfunction slot-definition))))
  923.     (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
  924.     slot-definition))
  925.  
  926. (defmethod effective-slot-definition-class ((class std-class) initargs)
  927.   (declare (ignore initargs))
  928.   *the-class-standard-effective-slot-definition*)
  929.  
  930. (defmethod compute-effective-slot-definition-initargs 
  931.     ((class slot-class) direct-slotds)
  932.   (let* ((name nil)
  933.      (initfunction nil)
  934.      (initform nil)
  935.      (initargs nil)
  936.      (allocation nil)
  937.          (documentation nil)
  938.      (type t)
  939.      (namep  nil)
  940.      (initp  nil)
  941.      (allocp nil)
  942.          (readers nil)
  943.          (writers nil)
  944.          (initfunction-side-effect-free-p nil))
  945.        (declare (type boolean namep initp allocp
  946.                               initfunction-side-effect-free-p))
  947.  
  948.     (dolist (slotd direct-slotds)
  949.       (when slotd
  950.     (unless namep
  951.       (setq name (slot-definition-name slotd)
  952.         namep t))
  953.     (unless initp
  954.       (setq initform (slot-definition-initform slotd))
  955.       (when (slot-definition-initfunction slotd)
  956.         (setq initfunction (slot-definition-initfunction slotd)
  957.                   initfunction-side-effect-free-p
  958.                     (slot-definition-initfunction-side-effect-free-p slotd)
  959.           initp t)))
  960.     (unless allocp
  961.       (setq allocation (slot-definition-allocation slotd)
  962.         allocp t))
  963.     (setq initargs (append (slot-definition-initargs slotd) initargs))
  964.     (let ((slotd-type (slot-definition-type slotd)))
  965.       (setq type (cond ((eq type 't) slotd-type)
  966.                ((*subtypep type slotd-type) type)
  967.                            ((*subtypep slotd-type type) slotd-type)
  968.                (t `(and ,type ,slotd-type)))))
  969.         (unless documentation
  970.           (setq documentation
  971.                 (fast-slot-value slotd 'documentation slow-slot-value)))
  972.         (dolist (reader (slot-definition-readers slotd))
  973.           (pushnew reader readers :test #'eq))
  974.         (dolist (writer (slot-definition-writers slotd))
  975.           (pushnew writer writers :test #'eq))))
  976.     (list :name name
  977.       :initform initform
  978.       :initfunction initfunction
  979.           :initfunction-side-effect-free-p initfunction-side-effect-free-p
  980.       :initargs initargs
  981.       :allocation allocation
  982.       :type type
  983.       :class class
  984.           :documentation documentation
  985.           :readers readers
  986.           :writers writers)))
  987.  
  988.  
  989.  
  990. ;;;
  991. ;;; NOTE: For bootstrapping considerations, these can't use make-instance
  992. ;;;       to make the method object.  They have to use make-a-method which
  993. ;;;       is a specially bootstrapped mechanism for making standard methods.
  994. ;;;
  995.  
  996. (defmethod add-reader-method ((class slot-class)
  997.                               generic-function 
  998.                               slot-name
  999.                               &optional
  1000.                               direct-slot)
  1001.   (let*
  1002.     ((reader-class
  1003.        (reader-method-class class direct-slot))
  1004.      (reader-prototype
  1005.        (when reader-class
  1006.          (assure-finalized reader-class)
  1007.          (class-prototype reader-class)))
  1008.      (method
  1009.        (make-a-method
  1010.          (if reader-class (class-name reader-class) 'standard-reader-method)
  1011.          ()
  1012.          (list (or (class-name class) 'standard-object))
  1013.          (list class)
  1014.          (when (call-store-method-function-p generic-function reader-prototype nil)
  1015.            (make-documented-reader-method-function
  1016.              class generic-function reader-prototype slot-name))
  1017.          (when (call-store-method-optimized-function-p
  1018.                  generic-function reader-prototype nil)
  1019.            (if (eq *boot-state* 'complete)
  1020.                (make-optimized-reader-method-function
  1021.                  class generic-function reader-prototype slot-name)
  1022.                (make-std-reader-method-function slot-name)))
  1023.          NIL
  1024.          "automatically generated reader method"
  1025.          slot-name
  1026.          `(,@(when direct-slot (list :slot-definition direct-slot))
  1027.            :needs-next-methods-p NIL))))
  1028.     (add-method generic-function method)))
  1029.  
  1030. (defmethod add-writer-method ((class slot-class)
  1031.                               generic-function 
  1032.                               slot-name
  1033.                               &optional
  1034.                               direct-slot)
  1035.   (let*
  1036.     ((writer-class
  1037.        (writer-method-class class direct-slot))
  1038.      (writer-prototype
  1039.        (when writer-class
  1040.          (assure-finalized writer-class)
  1041.          (class-prototype writer-class)))
  1042.      (method
  1043.        (make-a-method
  1044.          (if writer-class (class-name writer-class) 'standard-writer-method)
  1045.          ()
  1046.          (list 'new-value (or (class-name class) 'standard-object))
  1047.          (list *the-class-t* class)
  1048.          (when (call-store-method-function-p generic-function writer-prototype nil)
  1049.            (make-documented-writer-method-function
  1050.              class generic-function writer-prototype slot-name))
  1051.          (when (call-store-method-optimized-function-p
  1052.                  generic-function writer-prototype nil)
  1053.            (if (eq *boot-state* 'complete)
  1054.                (make-optimized-writer-method-function
  1055.                  class generic-function writer-prototype slot-name)
  1056.                (make-std-writer-method-function slot-name)))
  1057.          NIL
  1058.          "automatically generated writer method"
  1059.          slot-name
  1060.          `(,@(when direct-slot (list :slot-definition direct-slot))
  1061.            :needs-next-methods-p NIL))))
  1062.    (add-method generic-function method)))
  1063.  
  1064. (defmethod add-boundp-method ((class slot-class)
  1065.                               generic-function
  1066.                               slot-name
  1067.                               &optional
  1068.                               direct-slot)
  1069.   (let*
  1070.     ((boundp-class
  1071.        (boundp-method-class class direct-slot))
  1072.      (boundp-prototype
  1073.        (when boundp-class
  1074.          (assure-finalized boundp-class)
  1075.          (class-prototype boundp-class)))
  1076.      (method
  1077.        (make-a-method
  1078.          (if boundp-class (class-name boundp-class) 'standard-boundp-method)
  1079.          ()
  1080.          (list (or (class-name class) 'standard-object))
  1081.          (list class)
  1082.          (when (call-store-method-function-p generic-function boundp-prototype nil)
  1083.            (make-documented-boundp-method-function
  1084.              class generic-function boundp-prototype slot-name))
  1085.          (when (call-store-method-optimized-function-p
  1086.                  generic-function boundp-prototype nil)
  1087.            (if (eq *boot-state* 'complete)
  1088.                (make-optimized-boundp-method-function
  1089.                  class generic-function boundp-prototype slot-name)
  1090.                (make-std-boundp-method-function slot-name)))
  1091.          NIL
  1092.          "automatically generated boundp method"
  1093.          slot-name
  1094.          `(,@(when direct-slot (list :slot-definition direct-slot))
  1095.            :needs-next-methods-p NIL))))
  1096.     (add-method generic-function method)))
  1097.  
  1098.  
  1099. (defmethod reader-method-class ((class T)
  1100.                                 direct-slot
  1101.                                 &rest initargs)
  1102.   ;; To handle the case when a reader method is added before
  1103.   ;; standard-reader-method is defined.
  1104.   (declare (ignore direct-slot initargs))
  1105.   NIL)
  1106.  
  1107. (defmethod writer-method-class ((class T)
  1108.                                 direct-slot
  1109.                                 &rest initargs)
  1110.   ;; To handle the case when a writer method is added before
  1111.   ;; standard-writer-method is defined.
  1112.   (declare (ignore direct-slot initargs))
  1113.   NIL)
  1114.  
  1115. (defmethod boundp-method-class ((class T)
  1116.                                 direct-slot
  1117.                                 &rest initargs)
  1118.   ;; To handle the case when a boundp method is added before
  1119.   ;; standard-boundp-method is defined.
  1120.   (declare (ignore direct-slot initargs))
  1121.   NIL)
  1122.  
  1123.  
  1124. (defmethod remove-reader-method ((class slot-class) generic-function)
  1125.   (let ((method (get-method generic-function () (list class) nil)))
  1126.     (when method (remove-method generic-function method))))
  1127.  
  1128. (defmethod remove-writer-method ((class slot-class) generic-function)
  1129.   (let ((method
  1130.       (get-method generic-function () (list *the-class-t* class) nil)))
  1131.     (when method (remove-method generic-function method))))
  1132.  
  1133. (defmethod remove-boundp-method ((class slot-class) generic-function)
  1134.   (let ((method (get-method generic-function () (list class) nil)))
  1135.     (when method (remove-method generic-function method))))
  1136.  
  1137.  
  1138. ;;;
  1139. ;;; make-reader-method-function and make-write-method function are NOT part of
  1140. ;;; the standard protocol.  They are however useful, PCL makes uses makes use
  1141. ;;; of them internally and documents them for PCL users.
  1142. ;;;
  1143. ;;; *** This needs work to make type testing by the writer functions which
  1144. ;;; *** do type testing faster.  The idea would be to have one constructor
  1145. ;;; *** for each possible type test.  In order to do this it would be nice
  1146. ;;; *** to have help from inform-type-system-about-class and friends.
  1147. ;;;
  1148. ;;; *** There is a subtle bug here which is going to have to be fixed.
  1149. ;;; *** Namely, the simplistic use of the template has to be fixed.  We
  1150. ;;; *** have to give the optimize-slot-value method the user might have
  1151. ;;; *** defined for this metclass a chance to run.
  1152. ;;;
  1153.  
  1154. (defvar *documented-reader-method-function-makers* NIL)
  1155. (defvar *documented-writer-method-function-makers* NIL)
  1156. (defvar *documented-boundp-method-function-makers* NIL)
  1157.  
  1158. (defmethod make-documented-reader-method-function ((class slot-class)
  1159.                                                    generic-function
  1160.                                                    reader-method-prototype
  1161.                                                    slot-name)
  1162.   ;;   Make the documented reader-method-function.  To do this correctly for
  1163.   ;; all cases, we must build the reader method function by passing it
  1164.   ;; through make-method-lambda in case the user does something funky
  1165.   ;; with their method lambdas.
  1166.   ;;   Since there usually won't be many different kinds of method
  1167.   ;; lambdas for readers, this method actually dynamically builds a function
  1168.   ;; to make the documented-reader-method-function from each particular
  1169.   ;; method lambda returned and stores it in
  1170.   ;; *documented-reader-method-functions-makers* to be re-used each time
  1171.   ;; the reader lambda is the same.
  1172.   (multiple-value-bind (method-lambda initargs)
  1173.     (call-make-method-lambda generic-function
  1174.                              reader-method-prototype
  1175.                              '(lambda (instance)
  1176.                                 (funcall #'slot-value instance slot-name))
  1177.                              ())
  1178.     (declare (ignore initargs))
  1179.     (funcall-compiled
  1180.        (or (cdr (assoc method-lambda
  1181.                        *documented-reader-method-function-makers*
  1182.                        :test #'equal))
  1183.            (let ((reader-function-maker-name
  1184.                    (gensym "MAKE-DOCUMENTED-READER-METHOD-FUNCTION"))
  1185.                  (compiled-lambda
  1186.                    (compile-lambda
  1187.                      `(lambda (slot-name) (function ,method-lambda)))))
  1188.              (declare (type compiled-function compiled-lambda))
  1189.              (setf (symbol-function reader-function-maker-name)
  1190.                    compiled-lambda)
  1191.              (let ((func (eval `(function ,reader-function-maker-name))))
  1192.                (push (cons method-lambda func)
  1193.                      *documented-reader-method-function-makers*)
  1194.                func)))
  1195.       slot-name)))
  1196.  
  1197. (defmethod make-documented-writer-method-function ((class slot-class)
  1198.                                                    generic-function
  1199.                                                    writer-method-prototype
  1200.                                                    slot-name)
  1201.   ;;   Make the documented writer-method-function.  To do this correctly for
  1202.   ;; all cases, we must build the writer method function by passing it
  1203.   ;; through make-method-lambda in case the user does something funky
  1204.   ;; with their method lambdas.
  1205.   ;;   Since there usually won't be many different kinds of method
  1206.   ;; lambdas for writers, this method actually dynamically builds a function
  1207.   ;; to make the documented-writer-method-function from each particular
  1208.   ;; method lambda returned and stores it in
  1209.   ;; *documented-writer-method-functions-makers* to be re-used each time
  1210.   ;; the writer lambda is the same.
  1211.   (multiple-value-bind (method-lambda initargs)
  1212.     (call-make-method-lambda generic-function
  1213.                              writer-method-prototype
  1214.                              '(lambda (nv instance)
  1215.                                (funcall #'set-slot-value instance slot-name nv))
  1216.                              ())
  1217.     (declare (ignore initargs))
  1218.     (funcall-compiled
  1219.        (or (cdr (assoc method-lambda
  1220.                        *documented-writer-method-function-makers*
  1221.                        :test #'equal))
  1222.            (let ((writer-function-maker-name
  1223.                    (gensym "MAKE-DOCUMENTED-WRITER-METHOD-FUNCTION"))
  1224.                  (compiled-lambda
  1225.                    (compile-lambda
  1226.                      `(lambda (slot-name) (function ,method-lambda)))))
  1227.              (declare (type compiled-function compiled-lambda))
  1228.              (setf (symbol-function writer-function-maker-name)
  1229.                    compiled-lambda) 
  1230.              (let ((func (eval `(function ,writer-function-maker-name))))
  1231.                (push (cons method-lambda func)
  1232.                      *documented-writer-method-function-makers*)
  1233.                func)))
  1234.        slot-name)))
  1235.  
  1236. (defmethod make-documented-boundp-method-function ((class slot-class)
  1237.                                                    generic-function
  1238.                                                    boundp-method-prototype
  1239.                                                    slot-name)
  1240.   ;;   Make the documented boundp-method-function.  To do this correctly for
  1241.   ;; all cases, we must build the boundp method function by passing it
  1242.   ;; through make-method-lambda in case the user does something funky
  1243.   ;; with their method lambdas.
  1244.   ;;   Since there usually won't be many different kinds of method
  1245.   ;; lambdas for boundps, this method actually dynamically builds a function
  1246.   ;; to make the documented-boundp-method-function from each particular
  1247.   ;; method lambda returned and stores it in
  1248.   ;; *documented-boundp-method-functions-makers* to be re-used each time
  1249.   ;; the boundp lambda is the same.
  1250.   (multiple-value-bind (method-lambda initargs)
  1251.     (call-make-method-lambda generic-function
  1252.                              boundp-method-prototype
  1253.                              '(lambda (instance)
  1254.                                (funcall #'slot-value instance slot-name))
  1255.                              ())
  1256.     (declare (ignore initargs))
  1257.     (funcall-compiled
  1258.        (or (cdr (assoc method-lambda
  1259.                        *documented-boundp-method-function-makers*
  1260.                        :test #'equal))
  1261.            (let ((boundp-function-maker-name
  1262.                    (gensym "MAKE-DOCUMENTED-READER-METHOD-FUNCTION"))
  1263.                  (compiled-lambda
  1264.                    (compile-lambda
  1265.                      `(lambda (slot-name) (function ,method-lambda)))))
  1266.              (declare (type compiled-function compiled-lambda))
  1267.              (setf (symbol-function boundp-function-maker-name)
  1268.                    compiled-lambda)
  1269.              (let ((func (eval `(function ,boundp-function-maker-name))))
  1270.                (push (cons method-lambda func)
  1271.                      *documented-boundp-method-function-makers*)
  1272.                func)))
  1273.       slot-name)))
  1274.  
  1275. (defmethod make-optimized-reader-method-function ((class slot-class)
  1276.                                                   generic-function
  1277.                                                   reader-method-prototype
  1278.                                                   slot-name)
  1279.   (declare (ignore generic-function reader-method-prototype))
  1280.   (make-std-reader-method-function slot-name))
  1281.  
  1282. (defmethod make-optimized-writer-method-function ((class slot-class)
  1283.                                                   generic-function
  1284.                                                   writer-method-prototype
  1285.                                                   slot-name)
  1286.   (declare (ignore generic-function writer-method-prototype))
  1287.   (make-std-writer-method-function slot-name))
  1288.  
  1289. (defmethod make-optimized-boundp-method-function ((class slot-class)
  1290.                                                   generic-function
  1291.                                                   boundp-method-prototype
  1292.                                                   slot-name)
  1293.   (declare (ignore generic-function boundp-method-prototype))
  1294.   (make-std-boundp-method-function slot-name))
  1295.  
  1296. (defmethod make-optimized-reader-method-function ((class standard-class)
  1297.                                                   generic-function
  1298.                                                   reader-method-prototype
  1299.                                                   slot-name)
  1300.   (declare (ignore generic-function reader-method-prototype))
  1301.   (make-standard-instance-reader-method-function slot-name))
  1302.  
  1303. (defmethod make-optimized-writer-method-function ((class standard-class)
  1304.                                                   generic-function
  1305.                                                   writer-method-prototype
  1306.                                                   slot-name)
  1307.   (declare (ignore generic-function writer-method-prototype))
  1308.   (make-standard-instance-writer-method-function slot-name))
  1309.  
  1310. (defmethod make-optimized-boundp-method-function ((class standard-class)
  1311.                                                   generic-function
  1312.                                                   boundp-method-prototype
  1313.                                                   slot-name)
  1314.   (declare (ignore generic-function boundp-method-prototype))
  1315.   (make-standard-instance-boundp-method-function slot-name))
  1316.  
  1317.  
  1318. (defun make-standard-instance-reader-method-function (slot-name)
  1319.   (declare #.*optimize-speed*)
  1320.   #'(lambda (instance)
  1321.       (standard-instance-slot-value instance slot-name)))
  1322.  
  1323. (defun make-standard-instance-writer-method-function (slot-name)
  1324.   (declare #.*optimize-speed*)
  1325.   #'(lambda (nv instance)
  1326.       (setf (standard-instance-slot-value instance slot-name) nv)))
  1327.  
  1328. (defun make-standard-instance-boundp-method-function (slot-name)
  1329.   (declare #.*optimize-speed*)
  1330.   #'(lambda (instance)
  1331.       (standard-instance-slot-boundp instance slot-name)))
  1332.  
  1333.  
  1334.  
  1335. (defvar *internal-reader-gf-table* (make-hash-table :test 'eql))
  1336. (defvar *internal-writer-gf-table* (make-hash-table :test 'eql))
  1337. (defvar *internal-boundp-gf-table* (make-hash-table :test 'eql))
  1338.  
  1339. (defun get-reader-function (slot-name)
  1340.   (or (gethash slot-name *internal-reader-gf-table*)
  1341.       (error "No class has a slot named ~s" slot-name)))
  1342.  
  1343. (defun get-writer-function (slot-name)
  1344.   (or (gethash slot-name *internal-writer-gf-table*)
  1345.       (error "No class has a slot named ~s" slot-name)))
  1346.  
  1347. (defun get-boundp-function (slot-name)
  1348.   (or (gethash slot-name *internal-boundp-gf-table*)
  1349.       (error "No class has a slot named ~s" slot-name)))
  1350.  
  1351. (defun initialize-internal-slot-reader-gfs (slot-name)
  1352.   (unless (gethash slot-name *internal-reader-gf-table*)
  1353.     (let* ((name (slot-reader-symbol slot-name))
  1354.        (gf (setf (gethash slot-name *internal-reader-gf-table*)
  1355.              (ensure-generic-function name))))
  1356.       (add-reader-method *the-class-slot-object* gf slot-name))))
  1357.  
  1358. (defun initialize-internal-slot-writer-gfs (slot-name)
  1359.   (unless (gethash slot-name *internal-writer-gf-table*)
  1360.     (let* ((name (slot-writer-symbol slot-name))
  1361.        (gf (setf (gethash slot-name *internal-writer-gf-table*)
  1362.              (ensure-generic-function name))))
  1363.       (add-writer-method *the-class-slot-object* gf slot-name))))
  1364.  
  1365. (defun initialize-internal-slot-boundp-gfs (slot-name)
  1366.   (unless (or (not *optimize-slot-boundp*)
  1367.           (gethash slot-name *internal-boundp-gf-table*))
  1368.     (let* ((name (slot-boundp-symbol slot-name))
  1369.        (gf (setf (gethash slot-name *internal-boundp-gf-table*)
  1370.              (ensure-generic-function name))))
  1371.       (add-boundp-method *the-class-slot-object* gf slot-name))))
  1372.  
  1373.  
  1374. ;;;; inform-type-system-about-class
  1375. ;;;; make-type-predicate
  1376. ;;;
  1377. ;;; These are NOT part of the standard protocol.  They are internal mechanism
  1378. ;;; which PCL uses to *try* and tell the type system about class definitions.
  1379. ;;; In a more fully integrated implementation of CLOS, the type system would
  1380. ;;; know about class objects and class names in a more fundamental way and
  1381. ;;; the mechanism used to inform the type system about new classes would be
  1382. ;;; different.
  1383. ;;;
  1384. (defmethod inform-type-system-about-class ((class std-class) name)
  1385.   (inform-type-system-about-std-class name))
  1386.  
  1387.  
  1388.  
  1389. ;;;
  1390. ;;; These 4 definitions appear here for bootstrapping reasons.  Logically,
  1391. ;;; they should be in the construct file.  For documentation purposes, a
  1392. ;;; copy of these definitions appears in the construct file.  If you change
  1393. ;;; one of the definitions here, be sure to change the copy there.
  1394. ;;; 
  1395. (defvar *initialization-generic-functions*
  1396.     (list #'make-instance
  1397.           #'default-initargs
  1398.           #'allocate-instance
  1399.           #'initialize-instance
  1400.           #'shared-initialize))
  1401.  
  1402. (defmethod maybe-update-constructors
  1403.        ((generic-function generic-function)
  1404.         (method method))
  1405.   (when (memq generic-function *initialization-generic-functions*)
  1406.     (labels ((recurse (class)
  1407.            (update-constructors class)
  1408.            (dolist (subclass (class-direct-subclasses class))
  1409.          (recurse subclass))))
  1410.       (when (classp (car (method-specializers method)))
  1411.     (recurse (car (method-specializers method)))))))
  1412.  
  1413. (defmethod update-constructors ((class slot-class))
  1414.   (dolist (cons (class-constructors class))
  1415.     (install-lazy-constructor-installer cons)))
  1416.  
  1417. (defmethod update-constructors ((class class))
  1418.   ())
  1419.  
  1420.  
  1421.  
  1422. (defmethod compatible-meta-class-change-p (class proto-new-class)
  1423.   (eq (class-of class) (class-of proto-new-class)))
  1424.  
  1425. (defmethod validate-superclass ((class class) (new-super class))
  1426.   (or (eq new-super *the-class-t*)
  1427.       (eq (class-of class) (class-of new-super))))
  1428.  
  1429.  
  1430.  
  1431. ;;;
  1432. ;;;
  1433. ;;;
  1434. (defun force-cache-flushes (class)
  1435.   (let* ((owrapper (class-wrapper class))
  1436.      (state (wrapper-state owrapper)))
  1437.     ;;
  1438.     ;; We only need to do something if the state is still T.  If the
  1439.     ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
  1440.     ;; will already be doing what we want.  In particular, we must be
  1441.     ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
  1442.     ;; means do what FLUSH does and then some.
  1443.     ;; 
  1444.     (when (eq state 't)
  1445.       (let ((nwrapper (make-wrapper class)))
  1446.     (setf (wrapper-instance-slots-layout nwrapper)
  1447.           (wrapper-instance-slots-layout owrapper))
  1448.     (setf (wrapper-class-slots nwrapper)
  1449.           (wrapper-class-slots owrapper))
  1450.         (setf (wrapper-class-precedence-list nwrapper)
  1451.               (wrapper-class-precedence-list owrapper))
  1452.     (setf (wrapper-allocate-static-slot-storage-copy nwrapper)
  1453.           (wrapper-allocate-static-slot-storage-copy owrapper))
  1454.     (setf (wrapper-unreserved-field nwrapper)
  1455.           (wrapper-unreserved-field owrapper))
  1456.     (without-interrupts-simple
  1457.       (setf (slot-value class 'wrapper) nwrapper)
  1458.       (invalidate-wrapper owrapper 'flush nwrapper))
  1459.     (update-constructors class)))))        ;??? ***
  1460.  
  1461. (defun flush-cache-trap (owrapper nwrapper instance)
  1462.   (declare (ignore owrapper))
  1463.   (set-wrapper instance nwrapper))
  1464.  
  1465.  
  1466.  
  1467. ;;;
  1468. ;;; make-instances-obsolete can be called by user code.  It will cause the
  1469. ;;; next access to the instance (as defined in 88-002R) to trap through the
  1470. ;;; update-instance-for-redefined-class mechanism.
  1471. ;;; 
  1472. (defmethod make-instances-obsolete ((class std-class))
  1473.   (let ((owrapper (class-wrapper class))
  1474.     (nwrapper (make-wrapper class)))
  1475.       (setf (wrapper-instance-slots-layout nwrapper)
  1476.         (wrapper-instance-slots-layout owrapper))
  1477.       (setf (wrapper-class-slots nwrapper)
  1478.         (wrapper-class-slots owrapper))
  1479.       (setf (wrapper-class-precedence-list nwrapper)
  1480.             (wrapper-class-precedence-list owrapper))
  1481.       (setf (wrapper-allocate-static-slot-storage-copy nwrapper)
  1482.         (wrapper-allocate-static-slot-storage-copy owrapper))
  1483.       (setf (wrapper-unreserved-field nwrapper)
  1484.         (wrapper-unreserved-field owrapper))
  1485.       (without-interrupts-simple
  1486.     (setf (slot-value class 'wrapper) nwrapper)
  1487.     (invalidate-wrapper owrapper 'obsolete nwrapper)
  1488.     class)
  1489.       (dolist (generic-function (class-cached-in-generic-functions class))
  1490.         (update-dfun generic-function))))
  1491.  
  1492. (defmethod make-instances-obsolete ((class symbol))
  1493.   (make-instances-obsolete (find-class class)))
  1494.  
  1495.  
  1496. ;;;
  1497. ;;; obsolete-instance-trap is the internal trap that is called when we see
  1498. ;;; an obsolete instance.  The times when it is called are:
  1499. ;;;   - when the instance is involved in method lookup
  1500. ;;;   - when attempting to access a slot of an instance
  1501. ;;;
  1502. ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
  1503. ;;; access macros.
  1504. ;;;
  1505. ;;; Of course these times when it is called are an internal implementation
  1506. ;;; detail of PCL and are not part of the documented description of when the
  1507. ;;; obsolete instance update happens.  The documented description is as it
  1508. ;;; appears in 88-002R.
  1509. ;;;
  1510. ;;; This has to return the new wrapper, so it counts on all the methods on
  1511. ;;; obsolete-instance-trap-internal to return the new wrapper.  It also does
  1512. ;;; a little internal error checking to make sure that the traps are only
  1513. ;;; happening when they should, and that the trap methods are computing
  1514. ;;; apropriate new wrappers.
  1515. ;;; 
  1516. (defun obsolete-instance-trap (owrapper nwrapper instance)  
  1517.   ;;
  1518.   ;; local  --> local        transfer 
  1519.   ;; local  --> shared       discard
  1520.   ;; local  -->  --          discard
  1521.   ;; shared --> local        transfer
  1522.   ;; shared --> shared       discard
  1523.   ;; shared -->  --          discard
  1524.   ;;  --    --> local        add
  1525.   ;;  --    --> shared        --
  1526.   ;;
  1527.   (unless (or (std-instance-p instance) (fsc-instance-p instance))
  1528.     (error "Trying to obsolete instance ~S of type ~S, but only know how
  1529.             to obsolete instances of type STD-INSTANCE or FSC-INSTANCE."
  1530.            instance (instance-type instance)))
  1531.   (let* ((class (wrapper-class nwrapper))
  1532.      (guts (allocate-instance class))    ;??? allocate-instance ???
  1533.      (olayout (wrapper-instance-slots-layout owrapper))
  1534.      (nlayout (wrapper-instance-slots-layout nwrapper))
  1535.      (oslots (get-slots instance))
  1536.      (nslots (get-slots guts))
  1537.      (oclass-slots (wrapper-class-slots owrapper))
  1538.      (added ())
  1539.      (discarded ())
  1540.      (plist ()))
  1541.     (declare (list olayout nlayout oclass-slots added discarded plist)
  1542.              (simple-vector oslots nslots))
  1543.     ;;
  1544.     ;; Go through all the old local slots.
  1545.     ;; 
  1546.     (iterate ((name (list-elements olayout))
  1547.           (opos (interval :from 0)))
  1548.       (let ((npos (posq name nlayout)))
  1549.     (if npos
  1550.         (setf (svref nslots npos) (svref oslots opos))
  1551.         (progn (push name discarded)
  1552.            (unless (eq (svref oslots opos) *slot-unbound*)
  1553.              (setf (getf plist name) (svref oslots opos)))))))
  1554.     ;;
  1555.     ;; Go through all the old shared slots.
  1556.     ;;
  1557.     (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
  1558.       (let ((name (car oclass-slot-and-val))
  1559.         (val (cdr oclass-slot-and-val)))
  1560.     (let ((npos (posq name nlayout)))
  1561.       (if npos
  1562.           (setf (svref nslots npos) (cdr oclass-slot-and-val))
  1563.           (progn (push name discarded)
  1564.              (unless (eq val *slot-unbound*)
  1565.                (setf (getf plist name) val)))))))
  1566.     ;;
  1567.     ;; Go through all the new local slots to compute the added slots.
  1568.     ;; 
  1569.     (dolist (nlocal nlayout)
  1570.       (unless (or (memq nlocal olayout)
  1571.           (assq nlocal oclass-slots))
  1572.     (push nlocal added)))
  1573.       
  1574.     (without-interrupts-simple
  1575.       (set-wrapper instance nwrapper)
  1576.       (set-slots instance nslots))
  1577.  
  1578.     (update-instance-for-redefined-class instance
  1579.                      added
  1580.                      discarded
  1581.                      plist)
  1582.     nwrapper))
  1583.  
  1584.  
  1585.  
  1586. ;;;
  1587. ;;;
  1588. ;;;
  1589. (defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc)
  1590.   `(let* ((old-class (class-of instance))
  1591.       (copy (,alloc old-class))
  1592.       (guts (,alloc new-class))
  1593.       (new-wrapper (,wrapper-fetcher guts))
  1594.       (old-wrapper (class-wrapper old-class))
  1595.       (old-layout (wrapper-instance-slots-layout old-wrapper))
  1596.       (new-layout (wrapper-instance-slots-layout new-wrapper))
  1597.       (old-slots (,slots-fetcher instance))
  1598.       (new-slots (,slots-fetcher guts))
  1599.       (old-class-slots (wrapper-class-slots old-wrapper)))
  1600.     (declare (list old-layout new-layout old-class-slots)
  1601.              (simple-vector old-slots new-slots))
  1602.  
  1603.     ;;
  1604.     ;; "The values of local slots specified by both the class Cto and
  1605.     ;; Cfrom are retained.  If such a local slot was unbound, it remains
  1606.     ;; unbound."
  1607.     ;;     
  1608.     (iterate ((new-slot (list-elements new-layout))
  1609.           (new-position (interval :from 0)))
  1610.       (let ((old-position (posq new-slot old-layout)))
  1611.     (when old-position
  1612.       (setf (svref new-slots new-position)
  1613.         (svref old-slots old-position)))))
  1614.  
  1615.     ;;
  1616.     ;; "The values of slots specified as shared in the class Cfrom and
  1617.     ;; as local in the class Cto are retained."
  1618.     ;;
  1619.     (iterate ((slot-and-val (list-elements old-class-slots)))
  1620.       (let ((position (posq (car slot-and-val) new-layout)))
  1621.     (when position
  1622.       (setf (svref new-slots position) (cdr slot-and-val)))))
  1623.  
  1624.     ;; Make the copy point to the old instance's storage, and make the
  1625.     ;; old instance point to the new storage.
  1626.     (without-interrupts-simple
  1627.       (setf (,slots-fetcher copy) old-slots)
  1628.       
  1629.       (setf (,wrapper-fetcher instance) new-wrapper)
  1630.       (setf (,slots-fetcher instance) new-slots))
  1631.  
  1632.     (update-instance-for-different-class copy instance)
  1633.     instance))
  1634.  
  1635. (defmethod change-class ((instance standard-object)
  1636.              (new-class standard-class))
  1637.   (unless (std-instance-p instance)
  1638.     (error "Can't change the class of ~S to ~S~@
  1639.             because it isn't already an instance with metaclass~%~S."
  1640.        instance
  1641.        new-class
  1642.        'standard-class))
  1643.   (change-class-internal std-instance-wrapper
  1644.              std-instance-slots
  1645.              allocate-instance))
  1646.  
  1647. (defmethod change-class ((instance standard-object)
  1648.              (new-class funcallable-standard-class))
  1649.   (unless (fsc-instance-p instance)
  1650.     (error "Can't change the class of ~S to ~S~@
  1651.             because it isn't already an instance with metaclass~%~S."
  1652.        instance
  1653.        new-class
  1654.        'funcallable-standard-class))
  1655.   (change-class-internal fsc-instance-wrapper
  1656.              fsc-instance-slots
  1657.              allocate-instance))
  1658.  
  1659. (defmethod change-class ((instance t) (new-class-name symbol))
  1660.   (change-class instance (find-class new-class-name)))
  1661.  
  1662.  
  1663.  
  1664. ;;;
  1665. ;;; The metaclass BUILT-IN-CLASS
  1666. ;;;
  1667. ;;; This metaclass is something of a weird creature.  By this point, all
  1668. ;;; instances of it which will exist have been created, and no instance
  1669. ;;; is ever created by calling MAKE-INSTANCE.
  1670. ;;;
  1671. ;;; But, there are other parts of the protcol we must follow and those
  1672. ;;; definitions appear here.
  1673. ;;; 
  1674. (defmethod shared-initialize :before
  1675.        ((class built-in-class) slot-names &rest initargs)
  1676.   (declare (ignore slot-names initargs))
  1677.   (error "Attempt to initialize or reinitialize a built in class."))
  1678.  
  1679. (defmethod validate-superclass ((c class) (s built-in-class))
  1680.   (eq s *the-class-t*))
  1681.  
  1682.  
  1683.  
  1684. ;;;
  1685. ;;;
  1686. ;;;
  1687.  
  1688. (defmethod validate-superclass ((c slot-class)
  1689.                 (f forward-referenced-class))
  1690.   't)
  1691.  
  1692.  
  1693. ;;;
  1694. ;;;
  1695. ;;;
  1696.  
  1697. (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
  1698.   (pushnew dependent (plist-value metaobject 'dependents)))
  1699.  
  1700. (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
  1701.   (setf (plist-value metaobject 'dependents)
  1702.     (delete dependent (plist-value metaobject 'dependents))))
  1703.  
  1704. (defmethod map-dependents ((metaobject dependent-update-mixin) function)
  1705.   (declare (type real-function function))
  1706.   (dolist (dependent (plist-value metaobject 'dependents))
  1707.     (funcall function dependent)))
  1708.  
  1709.  
  1710. (declaim (ftype (function (T T) boolean) class-on-class-precedence-list-p))
  1711. (defun class-on-class-precedence-list-p (class1 class2)
  1712.   ;; Return whether class1 is on class2's class-precedence-list
  1713.   ;; without finalizing it.
  1714.   (if (class-finalized-p class2)
  1715.       (not (null (memq class1 (fast-slot-value class2 'class-precedence-list))))
  1716.       (let ((direct-superclasses (class-direct-superclasses class2)))
  1717.         (if (memq class1 direct-superclasses)
  1718.             T
  1719.             (dolist (superclass direct-superclasses NIL)
  1720.               (if (class-on-class-precedence-list-p class1 superclass)
  1721.                   (return T)))))))
  1722.  
  1723. (declaim (ftype (function (T) boolean) class-standard-p))
  1724. (defun class-standard-p (class)
  1725.   ;; Return whether class is standard without finalizing it.
  1726.   (if (class-finalized-p class)
  1727.       (not (null (memq *the-class-standard-object*
  1728.                        (fast-slot-value class 'class-precedence-list))))
  1729.       (let ((direct-superclasses (class-direct-superclasses class)))
  1730.         (if (memq *the-class-standard-object* direct-superclasses)
  1731.             T
  1732.             (dolist (superclass direct-superclasses NIL)
  1733.               (if (class-standard-p superclass)
  1734.                   (return T)))))))
  1735.  
  1736.  
  1737.